home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d12
/
v9n21.arc
/
DGSOUND.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-11-17
|
18KB
|
601 lines
{
▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄
█ █
█ TITLE : DGSOUND.TPU █
█ PURPOSE : Sound functions and procedures. █
█ AUTHOR : David Gerrold, CompuServe ID: 70307,544 █
█ _____________________________________________________________________ █
█ █
█ Written in Turbo Pascal, Version 5.5, █
█ with routines from TurboPower, Object Professional. █
█ █
█ Turbo Pascal is a product of Borland International. █
█ Object Professional is a product of TurboPower Software. █
█ _____________________________________________________________________ █
█ █
█ This is not public domain software. █
█ This software is copyright 1990, by David Gerrold. █
█ Permission is hereby granted for personal use. █
█ █
█ The Brass Cannon Corporation █
█ 9420 Reseda Blvd., #804 █
█ Northridge, CA 91324-2932. █
█ █
▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀
}
{ Compiler Directives ===================================================== }
{$A-} {Switch word alignment off, necessary for cloning}
{$R-} {Range checking off}
{$B-} {Boolean complete evaluation off}
{$S-} {Stack checking off}
{$I-} {I/O checking off}
{$N+,E+} {Simulate numeric coprocessor}
{$M 16384,0,327680} {stack and heap}
{$V-} {Variable range checking off}
{ Name ==================================================================== }
UNIT DgSound;
{
The purpose of this code is to provide a library of commonly needed
sounds and sound-managing routines.
}
{ Interface =============================================================== }
INTERFACE
USES
{ Object Professional Units }
OpCrt,
OpString,
{ Dg Units }
DgBit,
DgCrt;
{ Declarations ============================================================ }
CONST
SfxCues = 1; { enable beeps and bonks }
SfxKeyClick = 2; { enable keyclick }
SfxMusic = 4; { enable music }
SfxAllSounds = 7; { enable all sounds }
SfxSound : byte = 7; { configurable }
SfxOptions : byte = 7; { default options }
BuzzCounter : longint = 1;
TYPE
BombOb = Object
Procedure Incoming; { falling sound }
Procedure Boom; { explosion }
Procedure FlashBoom; { explosion with flash }
end;
VAR
Bomb : BombOb;
{ Sound Managment Routines ================================================ }
FUNCTION Sfx (Option : word) : boolean;
{ returns true if sound effects option is set }
PROCEDURE ToggleSfxCues;
{ Toggle sound cues on and off. }
PROCEDURE ToggleKeyClick;
{ Toggle Key click on and off. }
PROCEDURE ToggleMusic;
{ Toggle music cues on and off. }
PROCEDURE ToggleSound;
{ Toggle all sounds on and off. }
PROCEDURE KeyClick;
PROCEDURE CueClick;
PROCEDURE Beep;
PROCEDURE BeepBeep;
PROCEDURE BeepBoop;
PROCEDURE BoopBeep;
PROCEDURE Bonk;
PROCEDURE Noise (Start, { starting frequency }
Stop, { ending frequency }
Step, { step size }
TmPrStp, { time per step }
Times, { repeats of whole sound }
Pause { pause between repeats }
: Integer);
PROCEDURE BadBuzzer;
PROCEDURE RealBadBuzzer;
PROCEDURE IncBuzzer;
PROCEDURE IndustrialSiren;
{ ========================================================================= }
{ Implementation ========================================================== }
IMPLEMENTATION
{ ========================================================================= }
{ Sfx ===================================================================== }
FUNCTION Sfx (Option : word) : boolean;
BEGIN
Sfx := SfxOptions and Option = Option;
END;
{ ToggleSfxCues =========================================================== }
{$F+} PROCEDURE ToggleSfxCues; {$F-}
BEGIN
SfxOptions := ToggleBitMask (SfxOptions, SfxCues);
END;
{ ToggleClick ============================================================= }
{$F+} PROCEDURE ToggleKeyClick; {$F-}
BEGIN
SfxOptions := ToggleBitMask (SfxOptions, SfxKeyClick);
END;
{ ToggleMusic ============================================================= }
{$F+} PROCEDURE ToggleMusic; {$F-}
BEGIN
SfxOptions := ToggleBitMask (SfxOptions, SfxMusic);
END;
{ ToggleSound ============================================================= }
CONST
StoreSfxOptions : byte = 0;
{$F+} PROCEDURE ToggleSound; {$F-}
BEGIN
if SfxOptions = 0 then
SfxOptions := StoreSfxOptions
else begin
StoreSfxOptions := SfxOptions;
SfxOptions := 0;
end;
END;
{ KeyClick ================================================================ }
PROCEDURE KeyClick;
BEGIN
if not Sfx (SfxKeyClick) then exit;
Sound (55);
Delay (1);
NoSound;
END;
{ CueClick ================================================================ }
PROCEDURE CueClick;
BEGIN
if not Sfx (SfxCues) then exit;
Sound (55);
Delay (1);
NoSound;
END;
{ Beep ==================================================================== }
PROCEDURE Beep;
BEGIN
if not Sfx (SfxCues) then exit;
Sound (440);
Delay (25);
NoSound;
END;
{ BeepBeep ================================================================ }
PROCEDURE BeepBeep;
BEGIN
if not Sfx (SfxCues) then exit;
Sound (1760);
Delay (50);
NoSound;
Delay (40);
Sound (1760);
Delay (50);
NoSound;
END;
{ BeepBoop ================================================================ }
PROCEDURE BeepBoop;
BEGIN
if not Sfx (SfxCues) then exit;
Sound (440);
Delay (100);
Sound (330);
Delay (100);
NoSound;
END;
{ BoopBeep ================================================================ }
PROCEDURE BoopBeep;
BEGIN
if not Sfx (SfxCues) then exit;
Sound (330);
Delay (100);
Sound (440);
Delay (100);
NoSound;
END;
{ Bonk ==================================================================== }
PROCEDURE Bonk;
VAR
Loop : byte;
BEGIN
if not Sfx (SfxCues) then exit;
For Loop := 1 to 65 do begin
Sound (110);
Delay (1);
Sound (55);
Delay (1);
end;
NoSound;
END;
{ Noise =================================================================== }
PROCEDURE Noise (Start, { starting frequency }
Stop, { ending frequency }
Step, { step size }
TmPrStp, { time per step }
Times, { repeats of whole sound }
Pause { pause between repeats }
: Integer);
{
Code adapted from E. Kasey Kasemodel's NOISE.PAS.
Downloaded from CompuServe BPROGA forum.
}
VAR
Note, Diff, Loop : Integer;
BEGIN
Note := Start;
Diff := 0;
Loop := 0;
for Loop := 1 to times do begin
sound (Note); delay (TmPrStp); NoSound; { make sound the 1st time }
repeat
if start > stop then begin { noise goes down }
Note := Note - Step; { take step value away from current freq }
Diff := Note - Stop; { check difference between freq and stop }
end
else begin { noise goes up }
Note := Note + Step;
Diff := Stop - Note;
end;
sound (Note); delay (TmPrStp); NoSound; { produce updated sound }
until (Diff < 0); { keep looping til freq goes past stop }
Note := Start; { start over for another loop }
delay (Pause); { wait between loops }
end; {for Loop} { do again if necessary }
END;
{ IndustrialSiren ========================================================= }
PROCEDURE IndustrialSiren;
VAR
Loop : byte;
BEGIN
if not Sfx (SfxCues) then exit;
for Loop := 1 to 8 do begin
Noise (1000, 2000, 15, 2, 1, 0);
Noise (2000, 1000, 15, 2, 1, 0);
end;
END;
{ BadBuzzer =============================================================== }
PROCEDURE BadBuzzer;
BEGIN
if not Sfx (SfxCues) then exit;
Noise (1000, 2000, 500, 2, 20, 0);
END;
{ RealBadBuzzer =========================================================== }
PROCEDURE RealBadBuzzer;
BEGIN
if not Sfx (SfxCues) then exit;
Noise (1000, 2000, 500, 2, 200, 0);
END;
{ IncBuzzer =============================================================== }
PROCEDURE IncBuzzer;
VAR
Loop : longint;
BEGIN
inc (BuzzCounter, BuzzCounter);
for Loop := 1 to BuzzCounter do
RealBadBuzzer;
END;
{ ========================================================================= }
{ BombOb.Incoming ========================================================= }
PROCEDURE BombOb.InComing;
VAR Loop : word;
BEGIN
for Loop := 5000 downto 1000 do begin { falling note }
sound (Loop);
delay (1);
end;
nosound;
END;
{ BombOb.Boom ============================================================= }
PROCEDURE BombOb.Boom;
VAR
Loop, X, Y : word;
BEGIN
for Y := 1 to 5 do
for X := 80 to 100 do begin
sound (random (1000));
delay (1);
end;
for Loop := 1 to 1500 do begin { crumbling sound }
sound (random (1000));
delay (1);
end;
for Loop := 100 to 999 do begin { the diminishing sound }
sound (random (1000 - Loop));
delay (1);
end;
for Loop := 950 to 999 do begin { the echo }
sound (random (1000 - Loop));
delay (1);
end;
nosound;
END;
{ BombOb.FlashBoom ======================================================== }
PROCEDURE BombOb.FlashBoom;
TYPE
ScreenRowArray = array [1 .. 66] of string [132];
VAR
Loop, X : word;
ScreenRow : ^ScreenRowArray; { for storing screen }
AttrStr : string; { new attrs }
R1, G1, B1 : real; { color components }
R2, G2, B2 : real;
Factor : byte;
StoreRegs : array [1 .. 2, 1 .. 3] of byte; { save reg values }
Bg, { registers }
Fg : byte;
BEGIN
Bg := GetEgaRegister (Black); { get registers }
Fg := GetEgaRegister (White);
GetVgaRegister (Fg, StoreRegs [1, 1], StoreRegs [1, 2],StoreRegs [1, 3]);
GetVgaRegister (Bg, StoreRegs [2, 1], StoreRegs [2, 2],StoreRegs [2, 3]);
new (ScreenRow); { allocate memory }
for Loop := 1 to ScreenHeight do
ReadAttribute { read screen attrs }
(ScreenWidth, Loop, 1, ScreenRow^ [Loop]);
AttrStr := CharStr (chr (LightGray), ScreenWidth);
for Loop := 1 to ScreenHeight do { write White text }
WriteAttribute (AttrStr, Loop, 1);
SetVgaRegister (Fg, 63, 63, 63); { fg turns white }
Delay (150); { pause }
R1 := 63; G1 := 63; B1 := 63;
SetVgaRegister
(Bg, round (R1), round (G1), round(B1)); { bg turns white }
delay (150); { a bright white flash }
for Loop := 1 to 400 do begin { first shock wave }
sound (random (1000));
delay (1);
end;
nosound;
delay (50);
Factor := 15;
R2 := 63; G2 := 55; B2 := 30;
for Loop := 1 to Factor do begin { second shock wave }
for X := 1 to 20 do begin
sound (random (1000));
delay (1);
end;
if R1 > R2 then R1 := R1 - R1/Factor;
if G1 > G2 then G1 := G1 - G1/Factor;
if B1 > B2 then B1 := B1 - B1/Factor;
SetVgaRegister
(Bg, round (R1), round (G1), round(B1)); { black bg is white }
end;
Factor := 5;
R2 := 63; G2 := 50; B2 := 0;
for Loop := 1 to Factor do begin { second shock wave }
for X := 1 to 20 do begin
sound (random (1000));
delay (1);
end;
if R1 > R2 then R1 := R1 - R1/Factor;
if G1 > G2 then G1 := G1 - G1/Factor;
if B1 > B2 then B1 := B1 - B1/Factor;
SetVgaRegister
(Bg, round (R1), round (G1), round(B1)); { black bg is white }
end;
Factor := 10;
R2 := 63; G2 := 0; B2 := 0;
for Loop := 1 to Factor do begin { second shock wave }
for X := 1 to 20 do begin
sound (random (1000));
delay (1);
end;
if R1 > R2 then R1 := R1 - R1/Factor;
if G1 > G2 then G1 := G1 - G1/Factor;
if B1 > B2 then B1 := B1 - B1/Factor;
SetVgaRegister
(Bg, round (R1), round (G1), round(B1)); { black bg is white }
end;
for Loop := 100 to 999 do begin { the diminishing sound }
for x := 1 to 2 do begin
sound (random (1000 - Loop));
delay (1);
if Loop mod 30 = 0 then begin
R1 := 45 + Random (9); G1 := 20 + Random (15); B1 := Random (10);
SetVgaRegister (Bg, round (R1), round (G1), round (B1));
SetVgaRegister (Fg, 30 + Random (33), Random (33), Random (10));
end;
end;
end;
Factor := 7;
R2 := 0; G2 := 0; B2 := 0;
for Loop := 925 to 999 do begin { the echo }
sound (random (1000 - Loop));
delay (1);
if Loop mod 5 = 0 then begin
if R1 > R2 then R1 := R1 - R1/Factor;
if G1 > G2 then G1 := G1 - G1/Factor;
if B1 > B2 then B1 := B1 - B1/Factor;
SetVgaRegister
(Bg, round (R1), round (G1), round (B1)); { random Bg colors }
end;
end;
SetVgaRegister (Fg, StoreRegs [1, 1], StoreRegs [1, 2],StoreRegs [1, 3]);
SetVgaRegister (Bg, StoreRegs [2, 1], StoreRegs [2, 2],StoreRegs [2, 3]);
for Loop := 1 to ScreenHeight do
WriteAttribute (ScreenRow^ [Loop], Loop, 1);
nosound;
dispose (ScreenRow);
END;
{ ========================================================================= }
{ ========================================================================= }
{ Initialization ========================================================== }
{ No initialization needed. }
END.
{ ========================================================================= }
{ ========================================================================= }
VERSION HISTORY:
9005.05
Completely restructured for consistency with Object Professional.
9005.07
Added sound toggles for use with DgKbd unit. Allows procedures to
be stored in AltProcArray.
9006.01
Added Bomb object.
{ ========================================================================= }
NEED:
Chimes for hourly clock instead of beep-boop.
{ ========================================================================= }
(*
EXTRA NOISES
Not yet included.
{ IndustrialGrindNoise ==================================================== }
PROCEDURE IndustrialGrindNoise;
BEGIN
Noise (100, 50, 1, 15, 5, 100);
END;
{ RisingTones ============================================================= }
PROCEDURE RisingTones;
BEGIN
Noise (100, 250, 10, 50, 3, 100);
END;
{ Boink Boink ============================================================= }
PROCEDURE BoinkBoink;
BEGIN
Noise (2000, 250, 50, 5, 2, 100);
END;
{ BouncyNoise ============================================================= }
PROCEDURE BouncyNoise;
BEGIN
Noise (50, 2500, 50, 5, 4, 50);
END;
{ LaserChirp ============================================================== }
PROCEDURE LaserChirp;
BEGIN
Noise (4000, 1000, 150, 3, 3, 50);
Noise (1000, 4000, 150, 3, 3, 50);
END;
{ ChirpChirpFlammadiddle ================================================== }
PROCEDURE ChirpChirpFlammadiddle;
BEGIN
Noise (1000, 6000, 100, 3, 3, 50);
Noise (4000, 250, 80, 3, 2, 75);
Noise (50, 5500, 133, 4, 2, 25);
Noise (2000, 1000, 60, 3, 3, 50);
END;
{ IndustrialAlarm ========================================================= }
PROCEDURE IndustrialAlarm;
BEGIN
Noise (2000, 2400, 2, 2, 2, 50);
END;
{ ========================================================================= }
*)